Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/pdoxde/fileform.frm

Visual Basic Form | 1995-05-08 | 11.5 KB | 310 lines

VERSION 2.00
Begin Form FileForm
   BorderStyle     =   3  'Fixed Double
   Caption         =   "File Form"
   ClientHeight    =   3735
   ClientLeft      =   1935
   ClientTop       =   1665
   ClientWidth     =   5700
   ControlBox      =   0   'False
   FontBold        =   -1  'True
   FontItalic      =   0   'False
   FontName        =   "System"
   FontSize        =   9.75
   FontStrikethru  =   0   'False
   FontUnderline   =   0   'False
   Height          =   4140
   Icon            =   0
   Left            =   1875
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3735
   ScaleWidth      =   5700
   Top             =   1320
   Width           =   5820
   Begin DriveListBox DRV_Drives
      Height          =   315
      Left            =   2895
      TabIndex        =   7
      Top             =   3135
      Width           =   2475
   End
   Begin CommandButton BTN_Cancel
      Cancel          =   -1  'True
      Caption         =   "Cancel"
      Height          =   420
      Left            =   1560
      TabIndex        =   9
      Top             =   3120
      Width           =   1125
   End
   Begin CommandButton BTN_Ok
      Caption         =   "OK"
      Default         =   -1  'True
      Height          =   420
      Left            =   240
      TabIndex        =   8
      Top             =   3120
      Width           =   1125
   End
   Begin DirListBox DIR_Dirs
      Height          =   1880
      Left            =   2910
      TabIndex        =   5
      Top             =   880
      Width           =   2460
   End
   Begin FileListBox FIL_Files
      Height          =   1785
      Left            =   345
      Pattern         =   "*.db"
      TabIndex        =   2
      Top             =   885
      Width           =   2460
   End
   Begin TextBox TXT_TextBox
      Height          =   315
      Left            =   210
      TabIndex        =   1
      Text            =   "*.db"
      Top             =   405
      Width           =   2610
   End
   Begin Label LAB_Drives
      Caption         =   "Dri&ves:"
      Height          =   255
      Left            =   2835
      TabIndex        =   6
      Top             =   2850
      Width           =   765
   End
   Begin Label LAB_CurrentDir
      Caption         =   "---"
      Height          =   225
      Left            =   2895
      TabIndex        =   4
      Top             =   480
      Width           =   2445
   End
   Begin Label LAB_Directories
      Caption         =   "&Directories:"
      Height          =   240
      Left            =   2820
      TabIndex        =   3
      Top             =   150
      Width           =   1200
   End
   Begin Label LAB_FileName
      Caption         =   "File &Name:"
      Height          =   240
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1200
   End
Dim LastChange As Integer   'remember what changed last
Sub BTN_Cancel_Click ()
    TXT_TextBox.SetFocus
    FileForm.Hide
    CancelOp = True
End Sub
Sub BTN_OK_Click ()
    Select Case LastChange
        Case 0 To 1             'Text box control was last changed
            LastChange = False
            filespec = TXT_TextBox.text
            If IsFileName(filespec) Then
                HighLightTextBox
                FileForm.Hide
            End If
        Case 2               'Directory list control was last changed
            LastChange = False
            DIR_Dirs.path = DIR_Dirs.List(DIR_Dirs.ListIndex)
        End Select
    pdox1.filename.text = filespec
End Sub
Sub DIR_Dirs_Change ()
    ' propogate directory changes to other controls
    FIL_Files.path = DIR_Dirs.path
    LAB_CurrentDir.Caption = DIR_Dirs.path
    ChDir DIR_Dirs.path
End Sub
Sub DIR_Dirs_Click ()
    LastChange = 2  'remember that the DIR_Dirs control changed
End Sub
Sub DRV_Drives_Change ()
    ' change the DIR_Dirs control path, it will
    ' pass the change on to the FIL_Files control
    DIR_Dirs.path = DRV_Drives.Drive
    ChDrive (DRV_Drives.Drive)
End Sub
Sub FIL_Files_Click ()
    'echo the selected name in the Text box
    TXT_TextBox.text = FIL_Files.filename
End Sub
Sub FIL_Files_DblClick ()
    'we have a final selection from the File Save dialog
    TXT_TextBox.text = FIL_Files.filename
    BTN_OK_Click
End Sub
Sub FIL_Files_PathChange ()
    'Show the current search pattern in the TXT_TextBox control
    TXT_TextBox.text = FIL_Files.Pattern
    HighLightTextBox
End Sub
Sub FIL_Files_PatternChange ()
    TXT_TextBox.text = FIL_Files.Pattern
    HighLightTextBox
End Sub
Sub Form_Load ()
    LAB_CurrentDir.Caption = DIR_Dirs.path  'Show full path name in a label
    LastChange = 0                          'No controls have been modified
    DIR_Dirs.Height = FIL_Files.Height      'Align Drives box to Files box
End Sub
Sub Form_Unload (Cancel As Integer)
    Cancel = True   ' Don't unload form, just hide it
    FileForm.Hide
    CancelOp = True ' Notify Cardfile form of cancellation
End Sub
Sub HighLightTextBox ()
    TXT_TextBox.SelStart = 0
    TXT_TextBox.SelLength = Len(TXT_TextBox.text)
    TXT_TextBox.SetFocus
End Sub
Function IsFileName (filespec As String) As Integer
' This function accepts FileSpec, a string, as input, then
' checks to see if the string is a valid file path/expression.
' If FileSpec is valid, and specifies a new drive, pattern and/or
' directory, the directory and file list boxes are notified.
' If FileSpec contains a valid file name, the filename is placed
' in the form's text edit box and IsFileName() returns a value of
' TRUE.  If FileSpec does not contain a valid file name (ie, it
' contains directory name and/or a new file pattern and/or an
' invalid file/path expression), IsFileName() returns FALSE.
    Dim Index As Integer
    Dim OldDir As String
    Dim NewDir As String
    On Local Error Resume Next
    OldDir = CurDir$                    'Remember current directory
    filespec = LCase$(filespec)
    If Mid$(filespec, 2, 1) = ":" Then  'Does it specify new drive?
        ChDrive (filespec)
        DIR_Dirs.path = CurDir$
        If Err Then
            MsgBox Error$(Err), 0, "Disk Error"
            ChDrive (OldDir)
            DIR_Dirs.path = CurDir$
            IsFileName = False
            Exit Function
        Else filespec = Right$(filespec, Len(filespec) - 2)
        End If
    End If
    ChDir (filespec)
    If Err Then                     'Separate path/filename, try again
        While InStr(filespec, "\")      'Parse any directory info

            'NewDir gets text to the left of & including FileSpec's first "\"
            NewDir = NewDir + Left$(filespec, InStr(filespec, "\"))

            'FileSpec becomes the text to the right of the first "\"
            filespec = Right$(filespec, Len(filespec) - InStr(filespec, "\"))
        Wend

        If NewDir <> "" Then
            If Len(NewDir) > 1 Then NewDir = Left$(NewDir, Len(NewDir) - 1)'Remove ending "\"
            Err = 0
            ChDir (NewDir)
            If Err Then
                MsgBox "Invalid path: '" + NewDir + "'", 0, "Cardfile"
                IsFileName = False
            Else
                If ProcessFileSpec(filespec) Then
                    IsFileName = True
                Else
                    If (InStr(filespec, "*") = 0) And (InStr(filespec, "?") = 0) Then
                        ChDrive (OldDir)
                        ChDir (OldDir)
                    Else
                        DIR_Dirs.path = CurDir$     'Update file controls
                    End If
                    IsFileName = False
                End If
            End If
        Else
            IsFileName = ProcessFileSpec(filespec)
        End If
    Else
        'User specified a new, valid dir; update the file controls
        DIR_Dirs.path = filespec
    End If
End Function
Function ProcessFileSpec (filespec As String) As Integer
' This function accepts a string which may be a directory name,
' a wildcard pattern, or a file name.  The function returns TRUE
' if the string is a valid filename, and FALSE if the string is
' either an invalid filename or a directory specification.  If the
' string specifies a directory, ProcessFileSpec() changes the
' current directory and updates the appropriate form controls.
' Note: This procedure expects FileForm's caption to be set to
'       one of "File Save As", "File Open" or "File Merge" in order
'       to prompt the user appropriately (eg - 'Replace existing
'       file?' during File Save As, or "File not found' during
'       File Open/Merge).
    Dim MsgBoxResponse As Integer
    On Local Error Resume Next
    If filespec <> "" Then
        Err = 0
        ChDir (filespec)
        If Err Then     ' FileSpec is a filename or wildcard, not a dir
            If InStr(filespec, ".") = False Then filespec = filespec + ".crd"
            If Len(filespec) > 12 Then
                MsgBox ("Filename too long: '" + filespec + "'")
                ProcessFileSpec = False
            Else
                'Did user specify a new wildcard pattern?
                If InStr(filespec, "*") Or InStr(filespec, "?") Then
                    FIL_Files.Pattern = filespec
                    ProcessFileSpec = False
                Else
                    If filespec <> ".." Then
                        ' We're finished -- got a valid filename
                            If Dir$(filespec) = "" Then
                                If FileForm.Caption = "File Open" Or FileForm.Caption = "File Merge" Then
                                    MsgBox "No such file: " + filespec, 0, "Cardfile"
                                    ProcessFileSpec = False
                                Else
                                    TXT_TextBox.text = filespec
                                    ProcessFileSpec = True
                                End If
                            Else
                                If FileForm.Caption = "File Save As" Then
                                    MsgBoxResponse = MsgBox("Replace existing " + filespec + "?", 4 + 32 + 256, "Cardfile")
                                    If MsgBoxResponse = MB_YES Then
                                        Kill filespec
                                        TXT_TextBox.text = filespec
                                        ProcessFileSpec = True
                                    Else
                                        ProcessFileSpec = False
                                    End If
                                Else
                                    TXT_TextBox.text = filespec
                                    ProcessFileSpec = True
                                End If
                            End If
                        End If
                    End If
                End If
        Else   ' FileSpec was just a directory name
            ProcessFileSpec = False
        End If
    Else
        ' The user only specified a new drive (handled in IsFileName)
        ProcessFileSpec = False
    End If
End Function
Sub TXT_TextBox_Change ()
    LastChange = 1
End Sub